PATTERNS AND MUSIC

Some may remember I take great delight in upgrading ancient Pattern programs, not always entirely successfully due to differing graphic routines. Here is a collection of what I think are some of the most colourful, and making use of the new MIDi player supplied with version 4.01. Those who have purchased Alyce’s useful E-book will find more complex players for all Music files, which can also determine the completion of playing a file, so that like this MIDI player the new file can be selected automatically at the right moment. The purpose of the temporary little Dialog box for choosing Midi music or not, is to prevent program crashing after the patterns start.

Note the rather elaborate routine used after a pattern loop is complete to divert to the subroutine [halt]. This serves two purposes. It invokes an artificial Ctrl key pressed, to prevent any Screen saver obliterating the screen, and also checks if the MIDi file has finished playing, to stop the music and select another music file.

The routine [create] is based on DIR.BAS supplied with LB to create a sound$ array of all the MID files in the same Directory as the first MID file chosen. 'Pick' selects a file from the array at random after the first file has been played, others are then selected likewise. Notice in the [halt] and [delay] the use of

    scan
    calldll #kernel32,"Sleep",2000 as ulong,r as void

to avoid 100% CPU usage as suggested in a past News Letter by Dennis McKinney. [http://babek.info/libertybasicfiles/lbnews/nl105/MinimizeCPU.htm]

You are of course welcome to extract any pattern routine you fancy for other purpose. Any comments for the Conforum?

Gordon Sweet

DEMO

    nomainwin
    ux = 1 : uy = 1
    if DisplayWidth > 1000 then ux = 120 : uy = 90
    UpperLeftX = ux : UpperLeftY = uy
    tx$ = "Pattern Display with MIDi accompaniment"
    open tx$ for graphics_fs_nsb as #p
    dim dir$(10,3) : dim sound$(301)

[begin]
    redim dir$(10,3) : redim sound$(301)
    #p "discard; trapclose [quit]; down; size 1"
    #p "font arial 36 bold; fill 1 1 50"
    #p "backcolor 1 1 50; color yellow; place ";160+ux;" ";100+uy
    #p "\Liberty Patterns Show"
    #p "font arial 10; place ";280+ux;" ";140+uy
    #p "\by Gordon Sweet    Ver 2.6 - November 2004"
    #p "font arial 14 bold; place ";150+ux;" ";200+uy
    #p "color red; place ";100+ux;" ";240+uy
    #p "\Click below to Start or select any MIDi music accompaniment"
    #p "\Wait for MIDi to change when screen clears for a fresh pattern."
    #p "flush; font fixedsys" ' playwave "tada"
[begin.again]
    music = 0
    UpperLeftX = 250+ux : UpperLeftY = 350+uy
    WindowWidth = 300 : WindowHeight = 70
    button #s, " No music ", [spirals], UL 1, 10
    button #s, "With music", [music], UL 100, 10
    button #s, "** Quit **", [quit], UL 200, 10
    open "Click to Start" for dialog as #s
    #s "trapclose [quit]"
    #s "font fixedsys"
    playwave "ping" : box = 1
    mainH=hWnd(#s) : gosub [boxhold]
    wait
    close #s : box = 0

[music]
    close #s : box = 0
    DefaultDir$ = left$(DefaultDir$,2)+"\"
    filedialog "Select any MIDi file","*.mid",File$
    'if File$ = "" then wait
    if File$ = "" then goto [begin.again]
    start = 1 : gosub [create]
    #p "font arial 10 bold; place 20 20" : #p "|";File$ 
    halt = 1000 : gosub [delay]
    playmidi File$, howLong

[spirals]
    if box = 1 then close #s : box = 0
    dw = DisplayWidth/2 : dh = DisplayHeight/2
    #p "cls; size 2"
    for A = 30 to 175 step 6    ' ORIGINALY step 6
        #p "fill black; place ";dw;" ";dh
        for o = 0 to 600 step 4
            halt = 1 : gosub [delay]
            red = int(rnd(1) * 256)
            green = int(rnd(1) * 256)
            blue = int(rnd(1) * 256)
            #p "color ";red;" ";green;" ";blue
            #p "turn ";A
            #p "go ";int(o/3)
        next o
    gosub [halt]
    next A

[pixels]
    for pix = 1 to 4
        if pix > 2 then #p "size 2"
        #p "discard; fill black; color black"
        gosub [RGB] : GOSUB [init]
        count=1 : TS = T * S
        for R = 1 to 3
            FOR I = U TO N - 1 STEP K
                C = 1
                FOR J = V TO K
                    if X < 0 then nx = -1 'LB does not
                    if X = 0 then nx = 0    'not have a
                    if X > 0 then nx = 1    'SGN function
                    H = Y - nx * (ABS(B * X - C) ^ 0.5)
                    Y = A - X: X = H
                    PX = int(TS * (X + Y)) : PY = int(TS * (Y - X))
                    PX = PX / 2 + 440 + ux : PY = PY / 2 + 260 +uy
                    #p "set ";str$(PX);" ";str$(PY)
                    V = 1 : count = count + 1
                    if count/200 =int(count/200) then count=1 : gosub [RGB]
                NEXT J
                U = 0 : gosub [halt]
            NEXT I
        next R : gosub [halt]
    next pix
    goto [boxes]

[init] rem initialise
    A1 = 5: T1 = 8: E1 = 1
    A = INT(RND(1) * 1000/100 - RND(1) * 1000) / 100
    B = INT(RND(1) * 1000/100 - RND(1) * 1000) / 100
    C = INT(RND(1) * 1000/100 - RND(1) * 1000) / 100
    S = INT(RND(1) * 20) + 10
    N = INT(RND(1) * 1000) + 500: K = N / 5
    U = 0: V = 1
    X = 0: Y = 0
    sq = 2 ^ 0.5 'Square Root
    T = 1 / sq: E1 = 0: P1 = 0
    rem XC = 640 - A * S * T: YC = 512
    RETURN

[boxes]
    for pbox = 1 to 4
        #p "discard; fill black" : GOSUB [RGB]
        MAX = 800: STP = 4
        RES = 4: XP = 200: YP = 100
        X = (INT(RND(1) * (400 / RES)) + 1) * RES
        Y = (INT(RND(1) * (400 / RES)) + 1) * RES
        XST = (INT(RND(1) * STP) + 1) * RES
        YST = (INT(RND(1) * STP) + 1) * RES
        count = 1: CHANGE = 0
        WHILE CHANGE = 0
            IF count /5 <> INT(count/5) THEN GOTO [SAMECOL]
            GOSUB [RGB]
[SAMECOL] H = (X + XP) / 2 : V = (Y + YP) / 2.926 : gosub [repos]
            H = (X + XP) / 2 : V = (MAX - Y + YP) / 2.926 : gosub [line]
            H = (MAX - X + XP) / 2 : V = (MAX - Y + YP) / 2.926 : gosub [line]
            H = (MAX - X + XP) / 2 : V = (Y + YP) / 2.926 : gosub [line]
            H = (X + XP) / 2 : V = (Y + YP) / 2.926 : gosub [line]
            H = (Y + XP) / 2 : V = (X + YP) / 2.926 : gosub [repos]
            H = (Y + XP) / 2 : V = (MAX - X + YP) / 2.926 : gosub [line]
            H = (MAX - Y + XP) / 2 : V = (MAX - X + YP) / 2.926 : gosub [line]
            H = (MAX - Y + XP) / 2 : V = (X + YP) / 2.926 : gosub [line]
            H = (Y + XP) / 2 : V = (X + YP) / 2.926 : gosub [line]
            X = X + XST: IF X > MAX OR X < 0 THEN XST = XST - 2 * XST
            Y = Y + YST: IF Y > MAX OR Y < 0 THEN YST = YST - 2 * YST
            count = count + 1: IF count > 30 THEN count = 1: CHANGE = 1
        WEND : gosub [halt]
    next pbox
    goto [elipticals]

[repos]
    H = int(H) + 100 +ux : V = int(V) + 80 +uy
    #p "set ";str$(H);" ";str$(V)
    scan
    calldll #kernel32,"Sleep",1 as ulong,R as void
    return

[line] H = int(H) + 100 +ux : V = int(V) + 80+uy
    #p "goto ";str$(H);" ";str$(V)
    scan
    calldll #kernel32,"Sleep",1 as ulong,R as void
    return

[elipticals]
    #p "size 1; rule "; _R2_NOTXORPEN
    dw = DisplayWidth/2 : dh = DisplayHeight/2-50
    MAX = 306 : if dw < 1000 then MAX = 204
    C=int(rnd(1)*7)*6+3
    #p "discard; fill 0 0 10"
    for disp = 1 to 3
        C=int(rnd(1)*8+1)*16+16
        #p "discard; fill 0 0 10"
        for A = 16 to 306 step C
            gosub [RGB]
                for B = 16 to 306 step C
                    L = A
                    #p "place ";dw+L;" ";dh
                    #p "goto ";dw-L;" ";dh
                 for Y = 4 to B step 4
                        X = A/B*sqr(B*B-Y*Y)/2
                        X = X * 2
                        #p "place ";dw+X;" ";dh+Y
                        #p "goto ";dw-X;" ";dh+Y
                        #p "place ";dw+X;" ";dh-Y
                        #p "goto ";dw-X;" ";dh-Y
                        halt = 1 : gosub [delay]
                    next Y : gosub [halt]
                next B
        next A : halt = 1000 : gosub [delay]
    next disp
    #p "rule "; _R2_COPYPEN
    gosub [halt]

[kaleid]
    #p "fill black; backcolor black"
    dim bg$(12) : restore [colrs]
    for col = 1 to 12 ' store fill colors
        read r$ 
        bg$(col) = r$
    next col

    dim X(3, 3) : dim Y(3, 3) : dim XC(7) : dim YC(7)
    RESTORE [dat]
    FOR I = 1 TO 7
        read gen : XC(I) = gen
        read gen : YC(I) = gen
    NEXT I
    SCALE1 = 250: SCALE2 = 400
    FIN = 0: C = 1 : C = 0
    for kal = 1 to 4
' A single, B multiple patterns
        S$ = "A"
        FOR P = 1 TO 2
            #p "discard; color black; fill 0 0 30"
            IF P = 2 THEN S$ = "B"
            C = C + 1
            IF C = 4 THEN C = 1
            triags = int(rnd(1)*7)+1
            if triags < 3 then triags = int(rnd(1)*5)+3
            FOR L = 1 TO triags
                GOSUB [calcs]
                pick = int(rnd(1)*12) + 1
                pick$ = bg$(pick) 'fill color
                IF S$ = "A" THEN K = 1: GOTO [single]
                FOR K = 1 TO 7
[single]            GOSUB [triangs]
                IF S$ = "A" THEN GOTO [miss]
                NEXT K
[miss]     NEXT L
            gosub [halt]
        next P
    next kal : goto [persian]
[calcs]
    IF S$ = "A" THEN SCALE = SCALE2 ELSE SCALE = SCALE1
    FOR J = 1 TO 3
        R = SCALE * RND(1): TH = 1.047 * (RND(1) + .5)
        X(1, J) = R * COS(TH): Y(1, J) = R * SIN(TH)
        XH = X(1, J) / 2: XV = X(1, J) * .866
        YH = Y(1, J) * .866: YV = Y(1, J) / 2
        X(2, J) = YH + XH: Y(2, J) = 0-YV + XV
        X(3, J) = YH - XH: Y(3, J) = 0-YV - XV
    NEXT J : RETURN

[triangs]
    ' original screen sizes = 1280 x 1024
    ' X = X * .5 + 70 Y = Y * .5
    ' XC(K) & YC(K) = new screen origins
    FOR I = 1 TO 3
        kx = (X(I, 1)+XC(K))*.5+70:ky=(Y(I, 1)+YC(K))*.5
        #p "place ";kx+ux;" ";ky+uy
        kx = (X(I, 2)+XC(K))*.5+70:ky=(Y(I, 2)+YC(K))*.5
        #p "goto ";kx+ux;" ";ky+uy
        kx = (X(I, 3)+XC(K))*.5+70:ky=(Y(I, 3)+YC(K))*.5
        #p "goto ";kx+ux;" ";ky+uy
        kx = (X(I, 1)+XC(K))*.5+70:ky=(Y(I, 1)+YC(K))*.5
        #p "goto ";kx+ux;" ";ky+uy
        PX = (X(I, 1) + X(I, 2) + X(I, 3))/3
        PX = (PX+XC(K))*.5+70
        PY = (Y(I, 1) + Y(I, 2) + Y(I, 3))/3
        PY = (PY+YC(K))*.5
        gosub [fill]
        kx = (0-X(I, 1)+XC(K))*.5+70:ky=(Y(I, 1)+YC(K))*.5
        #p "place ";kx+ux;" ";ky+uy
        kx = (0-X(I, 2)+XC(K))*.5+70:ky=(Y(I, 2)+YC(K))*.5
        #p "goto ";kx+ux;" ";ky+uy
        kx = (0-X(I, 3)+XC(K))*.5+70:ky=(Y(I, 3)+YC(K))*.5
        #p "goto ";kx+ux;" ";ky+uy
        kx = (0-X(I, 1)+XC(K))*.5+70:ky=(Y(I, 1)+YC(K))*.5
        #p "goto ";kx+ux;" ";ky+uy
        PX = (0-X(I, 1) + 0-X(I, 2) + 0-X(I, 3))/3
        PX = (PX+XC(K))*.5+70
        PY = (Y(I, 1) + Y(I, 2) + Y(I, 3))/3
        PY = (PY+YC(K))*.5
        gosub [fill]
    NEXT I : RETURN


[persian]
    dw=DisplayWidth/2 : dh=DisplayHeight/2
    widt = DisplayWidth * .31
    higt = DisplayHeight * .23
    for pers = 1 to 5
        #p "discard; fill black"
        J1=0
        FOR K = widt TO higt STEP -60
            J1=J2
            red = int(rnd(1) * 256)
            green = int(rnd(1) * 256)
            blue = int(rnd(1) * 256)
            #p "color ";red;" ";green;" ";blue
            FOR I = 0-K TO K STEP 4
                halt = 1 : gosub [delay]
                #p "place ";dw+K;" ";dh+I
                #p "goto ";dw-K;" ";dh-I
                #p "place ";dw+I;" ";dh-K
                #p "goto ";dw-I;" ";dh+K
            NEXT I : gosub [halt]
        NEXT K
        halt = 2000 : gosub [delay]
    next pers

    goto [spirals] ' FIRST PATTERN

[fill]
    #p "backcolor ";pick$ 'color to fill with
    H=hwnd(#p) 'window handle
    calldll #user32, "GetDC",_
    H as long,_ 'window handle
    hDC as long 'returns device context

    wFillType=_FLOODFILLBORDER
    X = int(PX)+ux : Y = int(PY)+uy    'coords inside figure
    crColor = 0 'color of border
    'crColor = R + (g* 256) + (B*256*256)

    calldll #gdi32, "ExtFloodFill",_
        hDC As Long,_     'device context
        X As Long,_     'x location to start filling
        Y As Long,_     'y location to start filling
        crColor As Long,_ 'long color value of border, or color to replace
        wFillType As Long,_'flag for type of fill
        result As Long    'nonzero if successfull

    calldll #user32, "ReleaseDC",_
        H as long, hDC as long, re as long
    return

[RGB]
    red = int(rnd(1) * 256)
    green = int(rnd(1) * 256)
    blue = int(rnd(1) * 256)
    #p "color ";red;" ";green;" ";blue
    return

[delay]
    scan
    calldll #kernel32,"Sleep",halt as ulong,R as void
    return

[create]
    File$ = upper$(File$)
    sFile$ = noPath$(File$)
    plen = len(File$)-len(sFile$)
    path$ = left$(File$,plen)
    ext$ = "*."+right$(File$,3)
    files path$, ext$, dir$()
    qtyFiles = val(dir$(0, 0))
        if qtyFiles > 300 then
        notice "LIMIT of files set at 300!"
        qtyFiles = 300
    end if
    qtySubDirs = val(dir$(0, 1))
    if qtyFiles = 0 and qtySubDirs = 0 then
        notice "EMPTY DIRECTORY!!"
        goto [quit]
    end if
    if qtyFiles = 0 then notice "NO FILES??" : goto [quit]
'reformat the file information
    for X = 1 to qtyFiles
     dir$(X, 1) = right$("        " + dir$(X, 1), 9)
     sound$(X) = dir$(X, 0)
    next X
    maxsnd = X-1 : music = 1
    if start = 1 then start = 0 : return

[nextmid]
    pick = int(rnd(1) * maxsnd) + 1
    mid$ = path$+sound$(pick)
    for N = pick to maxsnd ' remove played from list
        sound$(N) = sound$(N+1)
    next N
    maxsnd = maxsnd -1
    if maxsnd < 1 then goto [create]
    #p "place 20 20" : #p "\                        "
    #p "place 20 20" : #p "|";mid$
    playmidi mid$, howLong
    halt = 1000 : gosub [delay]
    return

[halt]
    call KeybdEvent VK.CONTROL, 0 'simulates Ctrl Press
    scan
    calldll #kernel32,"Sleep",2000 as ulong,R as void
    if music = 0 then return
    if howLong = midipos( ) then
        stopmidi
        timer 0
        gosub [nextmid]
    end if
    return

[quit]
    if music = 1 then
        stopmidi
        timer 0
    end if
    if box = 1 then close #s
    close #p
    end

[colrs]
    data red, darkred, pink, darkpink, blue, darkblue
    data green, darkgreen, cyan, darkcyan, yellow, white

[dat]
DATA 640,514,370,994,910,994,1180,514,910,34,370,34,100,514

    function noPath$(t$)
    while instr(t$, "\")
    t$ = mid$(t$, 2)
    wend
    noPath$ = t$
    end function

    sub KeybdEvent key, event
    calldll #user32, "keybd_event",_
        key as short,_
        0 as short,_
        event as long,_
        0 as long,_
        ret as void
    end sub

[boxhold]
    open "user32" for dll as #user ' prevents losing box
        toTop=(-1 or 0)
        flags=_SWP_NOMOVE or _SWP_NOSIZE
    calldll #user,"SetWindowPos",mainH as ushort,toTop as short,_
    0 as short,0 as short,0 as short,0 as short,flags as ushort,_
    result as void
    close #user : return

---